home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HyperLib 1997 Winter - Disc 1
/
HYPERLIB-1997-Winter-CD1.ISO.7z
/
HYPERLIB-1997-Winter-CD1.ISO
/
オンラインウェア
/
UTIL
/
Alpha 6.5.sit
/
Tcl
/
Menus
/
colorsMenu.tcl
< prev
next >
Wrap
Text File
|
1996-08-15
|
8KB
|
399 lines
#===============================================================================
# Color menu and support routines
#
if $startingUp {
set colorMenu "・137"
addMenu colorMenu
return
}
proc colorMenu {} {}
menu -n $colorMenu -p colorMenuProc {
{menu -n Color -p colorMenuProc {
foreground
blue
cyan
green
magenta
red
white
yellow
"(-"
color_9
color_10
color_11
color_12
color_13
color_14
color_15
}}
{menu -n Style -p colorMenuProc {
"/B<U<Obold"
condense
extend
italic
normal
outline
shadow
"underline"
}}
"(-"
"/f<SredWord"
"/f<S<IredMark"
"/g<SblueWord"
"/g<S<IblueMark"
"/h<SgreenWord"
"/h<S<IgreenMark"
"underlineWord"
"(-"
"/H<UhyperText"
"urlLink"
"mailtoLink"
"/jlinkToFile"
"/k<SlinkToMark"
"/k<S<IlinkToFile&Mark"
"(-"
"listColors"
"removeColors"
}
proc redWord {} { colorSelect 5 0 ; centerRedraw }
proc blueWord {} { colorSelect 1 0 ; centerRedraw }
proc greenWord {} { colorSelect 3 0 ; centerRedraw }
proc redMark {} {
colorSelect 5 0
setNamedMark
centerRedraw
}
proc blueMark {} {
colorSelect 1 0
setNamedMark
centerRedraw
}
proc greenMark {} {
colorSelect 3 0
setNamedMark
centerRedraw
}
proc underlineWord {} {
insertColorEscape [getPos] 15
insertColorEscape [selEnd] 12
centerRedraw
}
proc colorMenuProc {menu item} {
switch $item {
black {colorSelect $item 0}
blue {colorSelect $item 0}
cyan {colorSelect $item 0}
green {colorSelect $item 0}
magenta {colorSelect $item 0}
red {colorSelect $item 0}
white {colorSelect $item 0}
yellow {colorSelect $item 0}
bold {colorSelect $item 12}
condense {colorSelect $item 12}
extend {colorSelect $item 12}
italic {colorSelect $item 12}
normal {colorSelect $item 12}
outline {colorSelect $item 12}
shadow {colorSelect $item 12}
underline {colorSelect $item 12}
hyperText {markAsHyper}
listColors {listColorEscapes}
removeColors {removeColorEscapes}
default {eval $item}
}
}
proc listColorEscapes {} {
set colors [getColors]
set res " Pos Code Hypertext¥n"
foreach item $colors {
set off [lindex $item 0]
set code [lindex $item 1]
set cmd [lreplace $item 0 1]
if {[string length $cmd]>1} {
append res [format "%7d %3d %s¥n" $off $code $cmd]
} else {
append res [format "%7d %3d¥n" $off $code]
}
}
if {[llength $colors]>0} {
new -n "* Color Codes *"
insertText $res
goto 0
catch {shrinkWindow 2}
set win [car [winNames -f]]
setWinInfo -w $win dirty 0
setWinInfo -w $win read-only 1
} else {
message "No color codes found"
}
}
#===============================================================================
set lastHyper {}
proc markAsHyper {} {
global lastHyper
set from [getPos]
set to [selEnd]
if {$from == $to} {
beep
return
}
set lastHyper [prompt "Hyper-text?" $lastHyper]
insertColorEscape $from 3
insertColorEscape $from 15 $lastHyper
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
proc colorSelect {ind ind2} {
set from [getPos]
set to [selEnd]
insertColorEscape $from $ind
insertColorEscape $to $ind2
}
proc linkToFile {{path {}} {from {}} {to {}}} {
global HOME
if {$from == {}} { set from [getPos] }
if {$to == {}} { set to [selEnd] }
if {$from == $to} {
beep
return
}
if {$path == {}} {
set path [getfile "Choose target of hyperlink:"]
# make path relative to Alpha's home folder
set qHome [quoteExpr $HOME]
regsub "$qHome" $path {$HOME} path
}
set cmd "edit ¥"$path¥""
insertColorEscape $from 3
insertColorEscape $from 15 $cmd
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
proc linkToMark {{mark {}} {from {}} {to {}}} {
if {$from == {}} { set from [getPos] }
if {$to == {}} { set to [selEnd] }
if {$from == $to} {
beep
return
}
set mark [listpick -p "Choose a Mark:" -L [list $mark] [getNamedMarks -n]]
set cmd "gotoMark ¥"$mark¥""
insertColorEscape $from 3
insertColorEscape $from 15 $cmd
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
proc urlLink {{from {}} {to {}}} {
if {$from == {}} { set from [getPos] }
if {$to == {}} { set to [selEnd] }
if {$from == $to} {
beep
return
}
set text [getText $from $to]
set cmd "sendUrl ¥"$text¥""
insertColorEscape $from 3
insertColorEscape $from 15 $cmd
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
proc mailtoLink {{from {}} {to {}}} {
if {$from == {}} { set from [getPos] }
if {$to == {}} { set to [selEnd] }
if {$from == $to} {
beep
return
}
set text [getText $from $to]
set cmd "sendUrl ¥"mailto:$text¥""
insertColorEscape $from 3
insertColorEscape $from 15 $cmd
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
proc linkToFile&Mark {{path {}} {mark {}} {from {}} {to {}}} {
global HOME
if {$from == {}} { set from [getPos] }
if {$to == {}} { set to [selEnd] }
if {$from == $to} {
beep
return
}
if {$path == {}} {
set path [getfile "Choose a file:"]
# make path relative to Alpha's home folder
set qHome [quoteExpr $HOME]
regsub "$qHome" $path {$HOME} path
}
set current [car [winNames -f]]
if {![catch {openFileQuietly $path}]} {
set mark [listpick -p "Choose a mark in that file:" -L [list $mark] [getNamedMarks -n -w $path]]
bringToFront $current
set cmd "edit ¥"$path¥" ; gotoMark ¥"$mark¥""
insertColorEscape $from 3
insertColorEscape $from 15 $cmd
insertColorEscape $to 12
insertColorEscape $to 0
centerRedraw
}
}
proc colorDummy {} {}
#===============================================================================
# Pete's manual-marking routines
proc markManual {} {
set pos 0
while {[string length [set inds [search -f 1 -r 1 {^ } $pos]]]} {
set pos1 [lindex $inds 1]
set label [getText $pos1 [expr [nextLineStart $pos1] - 1]]
set pos2 [lineStart $pos1]
setNamedMark $label $pos2 $pos2 $pos2
set pos [expr [nextLineStart $pos1]]
}
}
proc colorManualMarks {} {
goto 0
hiliteWord
endLineSelect
set from [getPos]
set to [selEnd]
insertColorEscape $from 5
insertColorEscape $from 15
insertColorEscape $to 12
insertColorEscape $to 0
foreach mk [getNamedMarks] {
set name [lindex $mk 0]
set disp [lindex $mk 2]
set pos [lindex $mk 3]
set end [lindex $mk 4]
goto $disp
hiliteWord
endLineSelect
set from [getPos]
set to [selEnd]
insertColorEscape $from 5
insertColorEscape $from 15
insertColorEscape $to 12
insertColorEscape $to 0
}
}
#===============================================================================
proc markAlphaCommands {} {
set pos 0
while {[string length [set inds [search -f 1 -r 1 {^・ } $pos]]]} {
set pos1 [lindex $inds 1]
goto $pos1
hiliteWord
set label [getSelect]
set from [getPos]
set to [selEnd]
setNamedMark $label $pos1 $from $to
insertColorEscape $from 1
insertColorEscape $to 0
set pos [expr [nextLineStart $pos1]]
}
}
#===============================================================================
proc markChanges {} {
set pos 0
while {[string length [set inds [search -f 1 -r 1 {^= } $pos]]]} {
set pos1 [lindex $inds 1]
goto $pos1
endLineSelect
redWord
set pos [expr [nextLineStart $pos1]]
}
}
#===============================================================================
proc listNamedMarks {} {
set nm [car [winNames -f]]
set res " Pos Disp End Name¥n"
append res "------- ------- ------- --------------------¥n"
foreach mk [getNamedMarks] {
set name [lindex $mk 0]
set disp [lindex $mk 2]
set pos [lindex $mk 3]
set end [lindex $mk 4]
append res [format "%7d %7d %7d %s¥n" $pos $disp $end $name]
}
if {[llength [getNamedMarks]]>0} {
new -n "* Named Marks *"
insertText $res
goto 0
catch {shrinkWindow 2}
set win [car [winNames -f]]
setWinInfo -w $win dirty 0
setWinInfo -w $win read-only 1
} else {
message "No color codes found"
}
}